home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Dylan Related / Mindy / Mindy 1.2 - portable sources / interp / list.c < prev    next >
Encoding:
C/C++ Source or Header  |  1995-03-15  |  6.7 KB  |  325 lines  |  [TEXT/ttxt]
  1. /**********************************************************************\
  2. *
  3. *  Copyright (c) 1994  Carnegie Mellon University
  4. *  All rights reserved.
  5. *  
  6. *  Use and copying of this software and preparation of derivative
  7. *  works based on this software are permitted, including commercial
  8. *  use, provided that the following conditions are observed:
  9. *  
  10. *  1. This copyright notice must be retained in full on any copies
  11. *     and on appropriate parts of any derivative works.
  12. *  2. Documentation (paper or online) accompanying any system that
  13. *     incorporates this software, or any part of it, must acknowledge
  14. *     the contribution of the Gwydion Project at Carnegie Mellon
  15. *     University.
  16. *  
  17. *  This software is made available "as is".  Neither the authors nor
  18. *  Carnegie Mellon University make any warranty about the software,
  19. *  its performance, or its conformity to any specification.
  20. *  
  21. *  Bug reports, questions, comments, and suggestions should be sent by
  22. *  E-mail to the Internet address "gwydion-bugs@cs.cmu.edu".
  23. *
  24. ***********************************************************************
  25. *
  26. * $Header: list.c,v 1.8 94/11/03 22:19:22 wlott Exp $
  27. *
  28. * This file implements lists.
  29. *
  30. \**********************************************************************/
  31.  
  32. #include "../compat/std-c.h"
  33.  
  34. #include "mindy.h"
  35. #include "gc.h"
  36. #include "coll.h"
  37. #include "class.h"
  38. #include "obj.h"
  39. #include "bool.h"
  40. #include "num.h"
  41. #include "thread.h"
  42. #include "func.h"
  43. #include "error.h"
  44. #include "print.h"
  45. #include "type.h"
  46. #include "def.h"
  47. #include "list.h"
  48.  
  49. obj_t obj_Nil = 0;
  50. obj_t obj_ListClass = 0, obj_PairClass = 0, obj_EmptyListClass = 0;
  51.  
  52. obj_t pair(obj_t head, obj_t tail)
  53. {
  54.     obj_t res = alloc(obj_PairClass, sizeof(struct list));
  55.  
  56.     HEAD(res) = head;
  57.     TAIL(res) = tail;
  58.  
  59.     return res;
  60. }
  61.  
  62. obj_t list1(obj_t x)
  63. {
  64.     return pair(x, obj_Nil);
  65. }
  66.  
  67. obj_t list2(obj_t x, obj_t y)
  68. {
  69.     return pair(x, list1(y));
  70. }
  71.  
  72. obj_t list3(obj_t x, obj_t y, obj_t z)
  73. {
  74.     return pair(x, list2(y, z));
  75. }
  76.  
  77. static obj_t vlistn(int n, va_list ap)
  78. {
  79.     obj_t res, *tail = &res;
  80.     int i;
  81.  
  82.     for (i = 0; i < n; i ++) {
  83.     obj_t new = list1(va_arg(ap, obj_t));
  84.     *tail = new;
  85.     tail = &TAIL(new);
  86.     }
  87.  
  88.     *tail = obj_Nil;
  89.  
  90.     return res;
  91. }
  92.  
  93. #if _USING_PROTOTYPES_
  94. obj_t listn(int n, ...)
  95. {
  96.     va_list ap;
  97.     obj_t res;
  98.  
  99.     va_start(ap, n);
  100.     res = vlistn(n, ap);
  101.     va_end(ap);
  102.  
  103.     return res;
  104. }
  105. #else
  106. obj_t listn(va_alist) va_dcl
  107. {
  108.     va_list ap;
  109.     int n;
  110.     obj_t res;
  111.  
  112.     va_start(ap);
  113.     n = va_arg(ap, int);
  114.     res = vlistn(n, ap);
  115.     va_end(ap);
  116.  
  117.     return res;
  118. }
  119. #endif
  120.  
  121. boolean memq(obj_t o, obj_t list)
  122. {
  123.     while (list != obj_Nil) {
  124.     if (o == HEAD(list))
  125.         return TRUE;
  126.     list = TAIL(list);
  127.     }
  128.     return FALSE;
  129. }
  130.  
  131. obj_t nreverse(obj_t list)
  132. {
  133.     obj_t result = obj_Nil;
  134.  
  135.     while (list != obj_Nil) {
  136.     obj_t t = TAIL(list);
  137.     TAIL(list) = result;
  138.     result = list;
  139.     list = t;
  140.     }
  141.     return result;
  142. }
  143.  
  144. int length(obj_t list)
  145. {
  146.     int count;
  147.  
  148.     for (count = 0; list != obj_Nil; list = TAIL(list))
  149.     count++;
  150.  
  151.     return count;
  152. }
  153.  
  154.  
  155. /* Dylan routines. */
  156.  
  157. static obj_t dylan_head(obj_t list)
  158. {
  159.     return HEAD(list);
  160. }
  161.  
  162. static obj_t dylan_head_setter(obj_t head, obj_t list)
  163. {
  164.     HEAD(list) = head;
  165.     return head;
  166. }
  167.  
  168. static obj_t dylan_tail(obj_t list)
  169. {
  170.     return TAIL(list);
  171. }
  172.  
  173. static obj_t dylan_tail_setter(obj_t tail, obj_t list)
  174. {
  175.     TAIL(list) = tail;
  176.     return tail;
  177. }
  178.  
  179. static void dylan_list(struct thread *thread, int nargs)
  180. {
  181.     obj_t *ptr = thread->sp;
  182.     obj_t result = obj_Nil;
  183.  
  184.     while (nargs-- > 0)
  185.     result = pair(*--ptr, result);
  186.  
  187.     thread->sp = ptr;
  188.     *--ptr = result;
  189.  
  190.     do_return(thread, ptr, ptr);
  191. }
  192.  
  193. static obj_t dylan_list_size(obj_t list)
  194. {
  195.     obj_t slow, fast;
  196.     int length;
  197.  
  198.     if (list == obj_Nil)
  199.     return make_fixnum(0);
  200.     if (object_class(list) != obj_PairClass)
  201.     type_error(list, obj_ListClass);
  202.  
  203.     slow = list;
  204.     fast = list;
  205.     length = 0;
  206.  
  207.     do {
  208.     fast = TAIL(fast);
  209.     if (fast == obj_Nil)
  210.         return make_fixnum(length+1);
  211.     if (object_class(fast) != obj_PairClass)
  212.         type_error(fast, obj_ListClass);
  213.     fast = TAIL(fast);
  214.     length += 2;
  215.     if (fast == obj_Nil)
  216.         return make_fixnum(length);
  217.     if (object_class(fast) != obj_PairClass)
  218.         type_error(fast, obj_ListClass);
  219.     slow = TAIL(slow);
  220.     } while (slow != fast);
  221.     return obj_False;
  222. }
  223.  
  224.  
  225. /* Printer support. */
  226.  
  227. static void print_list(obj_t list)
  228. {
  229.     int len = 0;
  230.  
  231.     printf("#(");
  232.     if (list != obj_Nil) {
  233.     while (1) {
  234.         prin1(HEAD(list));
  235.         list = TAIL(list);
  236.         if (list == obj_Nil)
  237.         break;
  238.         if (++len > 20) {
  239.         printf(" ...");
  240.         break;
  241.         }
  242.         if (!instancep(list, obj_ListClass)) {
  243.         printf(" . ");
  244.         prin1(list);
  245.         break;
  246.         }
  247.         printf(", ");
  248.     }
  249.     }
  250.     putchar(')');
  251. }
  252.  
  253.  
  254. /* GC support routines. */
  255.  
  256. static int scav_list(struct object *o)
  257. {
  258.     struct list *list = (struct list *)o;
  259.  
  260.     scavenge(&list->head);
  261.     scavenge(&list->tail);
  262.  
  263.     return sizeof(struct list);
  264. }
  265.  
  266. static obj_t trans_list(obj_t list)
  267. {
  268.     return transport(list, sizeof(struct list));
  269. }
  270.  
  271. void scavenge_list_roots(void)
  272. {
  273.     scavenge(&obj_Nil);
  274.     scavenge(&obj_ListClass);
  275.     scavenge(&obj_PairClass);
  276.     scavenge(&obj_EmptyListClass);
  277. }
  278.  
  279.  
  280. /* Init stuff. */
  281.  
  282. void make_list_classes(void)
  283. {
  284.     obj_ListClass = make_abstract_class(TRUE);
  285.     obj_PairClass = make_builtin_class(scav_list, trans_list);
  286.     obj_EmptyListClass = make_builtin_class(scav_list, trans_list);
  287. }
  288.  
  289. void init_nil(void)
  290. {
  291.     obj_Nil = alloc(obj_EmptyListClass, sizeof(struct list));
  292.     HEAD(obj_Nil) = obj_Nil;
  293.     TAIL(obj_Nil) = obj_Nil;
  294. }
  295.  
  296. void init_list_classes(void)
  297. {
  298.     init_builtin_class(obj_ListClass, "<list>", obj_MutSeqClass, NULL);
  299.     def_printer(obj_ListClass, print_list);
  300.     init_builtin_class(obj_PairClass, "<pair>", obj_ListClass, NULL);
  301.     init_builtin_class(obj_EmptyListClass, "<empty-list>",
  302.                obj_ListClass, NULL);
  303. }
  304.  
  305. void init_list_functions(void)
  306. {
  307.     define_function("pair", list2(obj_ObjectClass, obj_ObjectClass),
  308.             FALSE, obj_False, FALSE, obj_PairClass, pair);
  309.     define_function("head", list1(obj_ListClass),
  310.             FALSE, obj_False, FALSE, obj_ObjectClass, dylan_head);
  311.     define_function("head-setter", list2(obj_ObjectClass, obj_ListClass),
  312.             FALSE, obj_False, FALSE, obj_ObjectClass,
  313.             dylan_head_setter);
  314.     define_function("tail", list1(obj_ListClass),
  315.             FALSE, obj_False, FALSE, obj_ObjectClass, dylan_tail);
  316.     define_function("tail-setter", list2(obj_ObjectClass, obj_ListClass),
  317.             FALSE, obj_False, FALSE, obj_ObjectClass,
  318.             dylan_tail_setter);
  319.     define_constant("list",
  320.             make_raw_function("list", 0, TRUE, obj_False, FALSE,
  321.                       obj_Nil, obj_ObjectClass, dylan_list));
  322.     define_method("size", list1(obj_ListClass), FALSE, obj_False, FALSE,
  323.           obj_FixnumClass, dylan_list_size);
  324. }
  325.